perm filename MKIMAG[CRE,BGB] blob
sn#020874 filedate 1973-01-24 generic text, type T, neo UTF8
00100 SUBR(CRE)------------------------------------------------------
00200 BEGIN CRE;(Q1,Q2) - MAKE CRE STRUCTURE - BGB - 6 DEC 1972.
00300
00400 ;BIT POSITIONS OF THE ARGUMENTS Q1 & Q2 ENABLE INTENSITY CUTS.
00500 LAC 1,ARG2↔DAC 1,Q0
00600 LAC 1,ARG1↔ANDCMI 1,377↔DAC 1,Q1
00700 SETZM CUT#
00800
00900 ;MAKE THE IMAGE BLOCK AND THE LEVEL -1 FRAME POLYGON.
01000 SETQ IMAGE,{MKIMAG,FILM}
01100 SETQ LEVEL,{MKLEVL,IMAGE,[-1]}
01200 SETQ POLYGON,{MKFRAM,LEVEL}
01300 CALL(SEGTV)
01400
01500 ;FIND AN INTENSITY CONTOUR ENABLE BIT.
01600 L0: LAC 0,Q0↔LAC 1,Q1
01700 L1: AOS 2,CUT↔LSHC 0,1↔JUMPL 0,L2
01800 CAMN 0,1↔JUMPE 0,L5↔GO L1
01900
02000 ;THRESHOLD THE TVBUF
02100 L2: DAC 0,Q0↔DAC 1,Q1
02200 CALL(THRESH,CUT)
02300 CALL(PACXOR)
02400
02500 ;MAKE LEVEL NODE WITH A RING OF POLYGON NODES.
02600 SETQ(LEVEL,{MKLEVL,IMAGE,CUT})
02700 L3: SETQ(POLYGON,{MKPGON,LEVEL})
02800 JUMPN 1,L3↔LAC 1,LEVEL↔SON 1,1↔JUMPE 1,L0
02900
03000 ;LEVEL OPERATIONS.
03100 L4: CALL(VICONT,LEVEL)
03200 CALL(BABYKILLER,LEVEL)
03300 CALL(SMOOTH,LEVEL)
03400 CALL(ARCONT,LEVEL)
03500 CALL(MKTREE,LEVEL)
03600 CALL(BUNDLE,LEVEL)
03700 CALL(KILVIC,LEVEL)
03800 CALL(STADPY)
03900 GO L0
04000
04100 ;IMAGE OPERATIONS.
04200 L5: SETZ↔SKIPE FLGKRK↔CORE2↔JFCL
04300 LAC 1,LEVEL↔CCW 1,1↔CALL(KILVIC,1)
04400 CALL(MKWED1,IMAGE)
04500 CALL(MKWED2,IMAGE)
04600 LAC 1,IMAGE↔POP2J
04700
04800 DECLARE{Q0,Q1}
04900 BEND;1/10/73------------------------------------------------------
05000 DECLARE{IMAGE,LEVEL,POLYGON}
00100 SUBR(MKIMAG)FILM--------------------------------------------------
00200 BEGIN MKIMAG; MAKE IMAGE NODE - BGB - 10 JANUARY 1973.
00300 SETQ(IMAGE,{MAKE,[IBIT+IMGREL]})
00400 CALL(RINGIN,IMAGE,FILM)
00500 LAC 1,IMAGE↔LAC 2,FILM
00600 SON. 1,2↔DAD. 2,1
00700 LIPI 1,(1)↔DAC 1,3(1)↔DAC 1,4(1)↔DAC 1,5(1) ;FEV-RINGS.
00800 POP1J
00900 BEND;1/10/73------------------------------------------------------
01000
01100 SUBR(MKLEVL)IMAGE,CUT---------------------------------------------
01200 BEGIN MKLEVL; MAKE LEVEL NODE - BGB - 10 JANUARY 1973.
01300 SETQ(LEVEL,{MAKE,[LBIT+LVLREL]})
01400 CALL(RINGIN,LEVEL,IMAGE)
01500 LAC 1,LEVEL↔LAC 2,IMAGE
01600 LAC 0,ARG1↔NCNT. 0,1
01700 SKIPGE↔SON. 1,2↔DAD. 2,1
01800 POP2J
01900 BEND;1/10/73------------------------------------------------------
00100 SUBR(MKFRAM)LEVEL-------------------------------------------------
00200 BEGIN MKFRAM; MAKE FRAME POLYGON - BGB - 4 DEC 1972.
00300 ACCUMULATORS{R,C,N,S,E,W,M,LVL}
00400
00500 SETQ(M,{MAKE,[PBIT+PGNREL]})
00600 LAC LVL,ARG1↔DAD. LVL,1
00700 CALL(RINGIN,M,LVL)
00800 LACI R,=216⊗6↔LACI C,=288⊗6
00900
01000 ;VERTEX-POLYGON FRAME.
01100 SETQ(W,{MAKE,[VBIT+SOUBIT+VREL]})↔PGON. M,W
01200 SETQ(S,{MAKE,[VBIT+EASBIT+VREL]})↔PGON. M,S
01300 SETQ(E,{MAKE,[VBIT+NORBIT+VREL]})↔PGON. M,E
01400 SETQ(N,{MAKE,[VBIT+WESBIT+VREL]})↔PGON. M,N
01500 ROW. R,S↔ROW. R,E↔COL. C,E↔COL. C,N
01600 CW. N,W ↔ CW. E,N ↔ CW. S,E ↔ CW. W,S
01700 CCW. S,W ↔ CCW. E,S ↔ CCW. N,E ↔ CCW. W,N
01800 SON. W,M↔LAC 1,M↔SKIPN FLGKRK↔POP1J
01900
02000 ;MAKE THAT BIG ARRAY UP THERE IN THE SKY.
02100 L1: DETSEG↔LACI =217*=289↔CALLI 400015
02200 GO[FATAL(AIN'T NO MORE CORE UP YONDER.)]
02300 LAC[SIXBIT/SKYSEG/]↔CALLI 400036↔JFCL
02400 SETZ↔SEGNUM↔DAC SKYSEG
02500
02600 ;PUT THE FRAME UP IN THE SKY.
02700 LAC[XWD $,$+1]↔SETZM $↔BLT $+=217*=289-1
02800 L2: SETZ C,↔LACI R,=216↔DAP W,@SKY(R)↔SOJGE R,.-1
02900 LACI R,=216↔LACI C,=288↔DIP S,@SKY(R)↔SOJGE C,.-1
03000 LACI C,=288↔DAP E,@SKY(R)↔SOJGE R,.-1
03100 SETZ R,↔LACI C,=288↔DIP N,@SKY(R)↔SOJGE C,.-1
03200
03300 ;ARC-POLYGON FRAME.
03400 LACI R,=216⊗6↔LACI C,=288⊗6
03500 CALL(MAKE,[ARCBIT+VBIT+VREL])↔ARC. 1,W↔ARC. W,1↔LAC W,1
03600 CALL(MAKE,[ARCBIT+VBIT+VREL])↔ARC. 1,S↔ARC. S,1↔LAC S,1
03700 CALL(MAKE,[ARCBIT+VBIT+VREL])↔ARC. 1,E↔ARC. E,1↔LAC E,1
03800 CALL(MAKE,[ARCBIT+VBIT+VREL])↔ARC. 1,N↔ARC. N,1↔LAC N,1
03900 ROW. R,S↔ROW. R,E↔COL. C,E↔COL. C,N
04000 PGON. M,W↔PGON. M,S↔PGON. M,E↔PGON. M,N
04100 CW. N,W ↔ CW. E,N ↔ CW. S,E ↔ CW. W,S
04200 CCW. S,W ↔ CCW. E,S ↔ CCW. N,E ↔ CCW. W,N
04300 ARC. W,M
04400 L3: LAC 1,M↔POP1J
04500 BEND;1/10/73------------------------------------------------------
00100 SUBR(MKTREE)LEVEL-----------------------------------------------
00200 BEGIN MKTREE;MAKE POLYGON TREE STRUCTURE USING SKY ARRAY.
00300 ;BGB - 19 DECEMBER 1972.
00400 SKIPN FLGKRK↔POP1J
00500 DETSEG↔LAC SKYSEG
00600 ATTSEG↔GO[FATAL(SKYSEG ATTACH FAILURE IN MKIMAG.)]
00700
00800 ;PLACE POLYGONS OF THIS LEVEL IN THE TREE AND IN THE SKY.
00900 LAC 1,ARG1↔SON 1,1↔DAC 1,PG0#↔DAC 1,POLYGON
01000 L1: CALL(INTREE,POLYGON)
01100 LAC 1,POLYGON
01200 CCW 1,1
01300 DAC 1,POLYGON
01400 CAME 1,PG0↔GO L1
01500 DETSEG↔POP1J
01600 BEND;1/23/73------------------------------------------------------
01700
01800 SUBR(MKENDO)P1,P2-----------------------------------------------
01900 BEGIN MKENDO;PLACE P1 WITHIN P2 - BGB - 23 JANUARY 1973.
02000 LAC 1,ARG2↔LAC 2,ARG1
02100 EXO. 2,1↔ENDO 3,2 ;EXO(P1)←P2;P3←ENDO(P);
02200 JUMPN 3,.+5 ;IF P3=0 THEN BEGIN
02300 ENDO. 1,2↔PGON. 1,1 ;ENDO(P2)←NGON(P1)←PGON(P1)←P1;
02400 NGON. 1,1↔POP2J ;RETURN;END;
02500 NGON 4,3 ;P4←NGON(P3);
02600 PGON. 1,4↔NGON. 1,3 ;PGON(P4)←NGON(P3)←P1;
02700 NGON. 4,1↔PGON. 3,1 ;NGON(P1)←P4;PGON(P1)←P3;
02800 POP2J
02900 BEND;1/23/73------------------------------------------------------
03000
03100 SUBR(KLENDO)P1--------------------------------------------------
03200 BEGIN KLENDO;REMOVE P1 FROM THE TREE - BGB - 23 JANUARY 1973.
03300 LAC 1,ARG1
03400 NGON 2,1↔PGON 3,1 ;P2←NGON(P1);P3←PGON(P1);
03500 PGON. 3,2↔NGON. 2,3 ;PGON(P2)←P3;NGON(P3)←P2;
03600 NGON. 1,1↔PGON. 1,1 ;NGON(P1)←PGON(P1)←P1;
03700 CAMN 3,1↔SETZ 3, ;IF P3=P1 THEN P3←NIL;
03800 EXO 2,1↔ENDO 0,2 ;P2←EXO(P1);P0←ENDO(P2);
03900 CAMN 0,1↔ENDO. 3,2 ;IF P0=P1 THEN ENDO(P2)←P3;
04000 POP1J
04100 BEND;1/23/73------------------------------------------------------
00100 SUBR(INTREE)P1----------------------------------------------------
00200 BEGIN INTREE - PUT A POLY IN THE KRAKAUER TREE - BGB 11 DEC 1972.
00300 ACCUMULATORS{R,C,E,LST,P0,P1,P2,P3}
00400 LAC P1,ARG1
00500 SON E,P1↔JUMPE E,POP1J.
00600 LAC RC(E)↔ADD[XWD 40,40]
00700 CAR R,↔LSH R,-6
00800 CDR C,↔LSH C,-6
00900 TESTZ P1,HOLBIT↔SOS C
01000
01100 ;FIND THE VERTICAL EDGE DUE EAST OF HERE.
01200 L0: SKIPN 1,@SKY(R)↔SOJA C,L0
01300 TRNN 1,-1↔SOJA C,L0
01400 PGON P2,1↔CAMN P2,P1↔SOJA C,L0
01500
01600 ;PLACE P1 WITHIN P2, IN THE TREE AND IN THE SKY.
01700 TEST 1,SOUBIT↔EXO P2,P2
01800 CALL(MKENDO,P1,P2)
01900 CALL(INSKY,P1)
02000
02100 ;CONS UP LIST OF P2'S ENDO POLYGONS.
02200 LAC P1,ARG1↔HRLOI LST,0 ;LIST ← NIL.
02300 EXO P2,P1↔ENDO P3,P2↔JUMPE P3,POP1J. ;AIN'T NONE.
02400 DAC P3,P0
02500 L1: CAMN P3,P1↔GO L2
02600 PTIME. LST,P3↔LAC LST,P3 ;CONS P3 TO LIST.
02700 L2: NGON P3,P3↔CAME P3,P0↔GO L1 ;CDR THE RING.
02800
00100 ;SCAN LIST FOR P1 ENDO POLYGONS. P2←CDR(LIST).
00200 L3: CAIN LST,-1↔SETZ LST,
00250 SKIPN P2,LST↔POP1J↔SON E,P2
00300 LAC RC(E)↔ADD[XWD 40,40]
00400 CAR R,↔LSH R,-6
00500 CDR C,↔LSH C,-6
00600
00700 ;SCAN FOR FIRST POLYGON TO THE EAST OF P2.
00800 L4: SKIPN 1,@SKY(R)↔SOJA C,L4
00900 TRNN 1,-1↔SOJA C,L4
01000 PGON P3,1↔CAMN P3,LST↔SOJA C,L4
01100 TESTZ 1,SOUBIT↔GO L5 ;SON OR SISTER ?
01200
01300 ;IF SISTER IS NOT ON THE LIST THEN EXO(P3) IS VALID.
01400 L4A: LAC P0,P3↔EXO P3,P3
01500 PTIME 0,P0↔JUMPE 0,L5
01600 ;IF SISTER IS ON LIST THEN EXO(P3) IS NOT YET VALID.
01700 NTIME 0,P0↔NTIME. 0,P2
01800 NTIME. P2,P0↔GO L6
01900
02000 ;CHECK FOR P1 CAPTURE OF P2. P3 IS THE SKY-EXO(P2).
02100 L5: EXO 0,P2↔CAMN 0,P3↔GO L6 ;EXO(P2)=SKYEXO(P2).
02200 ; CAME P1,P3↔GO[FATAL({SKY EXO ≠ EXO INTREE.})]
02300 CALL(KLENDO,P2)
02400 CALL(MKENDO,P2,P1)
02500
02600 ;CAPTURE ELDER SISTERS IF ANY.
02700 L6: LAC 1,P2↔SETZ
02800 NTIME P2,P2↔NTIME. 0,1
02900 JUMPN P2,L5
03000
03100 ;CDR THE LIST OF POTENTIAL ENDO POLYGONS.
03200 LAC 1,LST↔SETZ
03300 PTIME LST,LST↔PTIME. 0,1
03400 GO L3
03500 BEND;1/23/73------------------------------------------------------
00100 SUBR(INSKY)PGON---------------------------------------------------
00200 BEGIN INSKY; PLACE A POLYGON IN THE SKY - BGB - 7 DEC 1972.
00300 ACCUMULATORS{R,C,R2,C2,E,E2}
00400 ;XWD HORIZONTAL,,VERTICAL.
00500 LAC 1,ARG1↔SON E,1↔DAC E,E0#↔JUMPE E,POP1J.
00600 DEFINE ADVANCE{
00700 LAC E,E2↔LAC R,R2↔LAC C,C2
00800 CCW E2,E2↔LAC RC(E2)↔ADD[XWD 40,40]
00900 CAR R2,↔LSH R2,-6
01000 CDR C2,↔LSH C2,-6}
01100 CW E2,E↔ADVANCE↔ADVANCE↔GO SSA
01200
01300 ;SOUTH ↓ BOUND.
01400 S0: CAMN E,E0↔POP1J
01500 SSA: CDR 1,@SKY(R)↔EXO. 1,E
01600 S1: CDR 1,@SKY(R)↔DAP E,@SKY(R)↔JUMPE 1,.+6
01700 ROW 0,1↔ADDI 40↔LSH -6↔CAMN 0,R↔ENDO. E,1
01800 CAIE R2,(R)1↔AOJA R,S1↔ADVANCE
01900 TEST E,EASBIT↔GO W0↔GO EE0
02000
02100 ;NORTH ↑ BOUND.
02200 N0: SOS R↔CDR 1,@SKY(R)↔EXO. 1,E
02300 N1: CDR 1,@SKY(R)↔DAP E,@SKY(R)↔JUMPE 1,.+6
02400 ROW 0,1↔ADDI 40↔LSH -6↔ CAIN 0,(R)1↔ENDO. E,0
02500 CAME R,R2↔SOJA R,N1↔ADVANCE
02600 TEST E,EASBIT↔GO W0↔GO EE0
02700
02800 ;EASTBOUND→.
02900 EE0: CAR 1,@SKY(R)↔EXO. 1,E
03000 EE1: CAR 1,@SKY(R)↔DIP E,@SKY(R)↔JUMPE 1,.+6
03100 COL 0,1↔ADDI 40↔LSH -6↔CAMN 0,C↔ENDO. E,1
03200 CAIE C2,(C)1↔AOJA C,EE1↔ADVANCE
03300 TEST E,NORBIT↔GO S0↔GO N0
03400
03500 ;←WESTBOUND.
03600 W0: SOS C↔CAR 1,@SKY(R)↔EXO. 1,E
03700 W1: CAR 1,@SKY(R)↔DIP E,@SKY(R)↔JUMPE 1,.+6
03800 COL 0,1↔ADDI 40↔LSH -6↔CAIN 0,(C)1↔ENDO. E,1
03900 CAME C,C2↔SOJA C,W1↔ADVANCE
04000 TEST E,NORBIT↔GO S0↔GO N0
04100
04200 BEND;12/13/72-----------------------------------------------------
00100 SUBR(KILVIC)LEVEL-------------------------------------------------
00200 BEGIN KILVIC; BGB - 5 JANUARY 1973.
00300 ;KILL VIDEO INTENSITY CONTOURS OF THE PREVIOUS LEVEL.
00400 ACCUMULATORS{PG,E0,E1,E2,PG0}
00500
00600 SKIPN FLGARC↔POP1J ;MAKE ARC ENABLE.
00700 SKIPN FLGU↔POP1J
00800 LAC 1,ARG1↔CW 1,1
00900 SON PG,1
01000 SKIPN PG0,PG↔POP1J
01100
01200 ;RELEASE VIC NODES OF THE POLYGON.
01300 L1: SON E0,PG
01400 JUMPE E0,L3
01500 SETZ↔SON. 0,PG
01600 LAC E1,E0
01700 L2: CCW E2,E1
01800 SETZ 0↔ARC 1,E1↔SKIPE 1↔ARC. 0,1
01900 CALL(KILL,E1)
02000 CAMN E2,E0↔GO L3
02100 LAC E1,E2↔GO L2
02200
02300 ;ADVANCE TO NEXT POLYGON ON THIS LEVEL.
02400 L3: CCW PG,PG
02500 CAME PG,PG0↔GO L1
02600 POP1J
02700
02800 BEND;1/5/73-------------------------------------------------------